home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / vms / test.com < prev    next >
Text File  |  1998-07-22  |  6KB  |  235 lines
  1. $!  Test.Com - DCL driver for perl5 regression tests
  2. $!
  3. $!  Version 1.1   4-Dec-1995
  4. $!  Charles Bailey  bailey@genetics.upenn.edu
  5. $
  6. $!  A little basic setup
  7. $   On Error Then Goto wrapup
  8. $   olddef = F$Environment("Default")
  9. $   oldmsg = F$Environment("Message")
  10. $   If F$Search("t.dir").nes.""
  11. $   Then
  12. $       Set Default [.t]
  13. $   Else
  14. $       If F$TrnLNm("Perl_Root").nes.""
  15. $       Then 
  16. $           Set Default Perl_Root:[t]
  17. $       Else
  18. $           Write Sys$Error "Can't find test directory"
  19. $           Exit 44
  20. $       EndIf
  21. $   EndIf
  22. $   Set Message /Facility/Severity/Identification/Text
  23. $
  24. $   exe = ".Exe"
  25. $   If p1.nes."" Then exe = p1
  26. $   If F$Extract(0,1,exe) .nes. "."
  27. $   Then
  28. $     Write Sys$Error ""
  29. $     Write Sys$Error "The first parameter passed to Test.Com must be the file type used for the"
  30. $     Write Sys$Error "images produced when you built Perl (i.e. "".Exe"", unless you edited"
  31. $     Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command line."
  32. $     Write Sys$Error ""
  33. $     Exit 44
  34. $   EndIf
  35. $!  Pick up a copy of perl to use for the tests
  36. $   Delete/Log/NoConfirm Perl.;*
  37. $   Copy/Log/NoConfirm [-]Perl'exe' []Perl.
  38. $
  39. $!  Make the environment look a little friendlier to tests which assume Unix
  40. $   cat = "Type"
  41. $   Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input
  42.         .title echo
  43.         .psect data,wrt,noexe
  44.     dsc:
  45.         .word 0
  46.         .byte 14 ; DSC$K_DTYPE_T
  47.         .byte 2  ; DSC$K_CLASS_D
  48.         .long 0
  49.         .psect code,nowrt,exe
  50.         .entry    echo,^m<r2,r3>
  51.         movab    dsc,r2
  52.         pushab    (r2)
  53.         calls    #1,G^LIB$GET_FOREIGN
  54.         movl    4(r2),r3
  55.         movzwl    (r2),r0
  56.         addl2    4(r2),r0
  57.         cmpl    r3,r0
  58.         bgtru    sym.3
  59.         nop    
  60.     sym.1:
  61.         movb    (r3),r0
  62.         cmpb    r0,#65
  63.         blss    sym.2
  64.         cmpb    r0,#90
  65.         bgtr    sym.2
  66.         cvtbl    r0,r0
  67.         addl2    #32,r0
  68.         cvtlb    r0,(r3)
  69.     sym.2:
  70.         incl    r3
  71.         movzwl    (r2),r0
  72.         addl2    4(r2),r0
  73.         cmpl    r3,r0
  74.         blequ    sym.1
  75.     sym.3:
  76.         pushab    (r2)
  77.         calls    #1,G^LIB$PUT_OUTPUT
  78.         movl    #1,r0
  79.         ret    
  80.         .end echo
  81. $   Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj;
  82. $   Delete/Log/NoConfirm Echo.Obj;*
  83. $   echo = "$" + F$Parse("Echo.Exe")
  84. $
  85. $!  And do it
  86. $   Show Process/Accounting
  87. $   testdir = "Directory/NoHead/NoTrail/Column=1"
  88. $   Define/User Perlshr Sys$Disk:[-]PerlShr'exe'
  89. $   MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p2'" "''p3'" "''p4'" "''p5'" "''p6'"
  90. $   Deck/Dollar=$$END-OF-TEST$$
  91. # $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
  92. # Modified for VMS 30-Sep-1994  Charles Bailey  bailey@genetics.upenn.edu
  93. #
  94. # This is written in a peculiar style, since we're trying to avoid
  95. # most of the constructs we'll be testing for.
  96.  
  97. # skip those tests we know will fail entirely or cause perl to hang bacause
  98. # of Unixisms in the tests.  (The Perl operators being tested may work fine,
  99. # but the tests may use other operators which don't.)
  100. use Config;
  101.  
  102. @compexcl=('cpp.t');
  103. @ioexcl=('argv.t','dup.t','fs.t','pipe.t');
  104. @libexcl=('db-btree.t','db-hash.t','db-recno.t',
  105.           'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sel.t', 'io_sock.t',
  106.           'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t');
  107.  
  108. # Note: POSIX is not part of basic build, but can be built
  109. # separately if you're using DECC
  110. # io_xs.t tests the new_tmpfile routine, which doesn't work with the
  111. # VAXCRTL, since the file can't be stat()d, an Perl's do_open()
  112. # insists on stat()ing a file descriptor before it'll use it.
  113. push(@libexcl,'io_xs.t') if $Config{'vms_cc_type'} ne 'decc';
  114.  
  115. @opexcl=('die_exit.t','exec.t','fork.t','glob.t','groups.t','magic.t','misc.t','stat.t');
  116. @exclist=(@compexcl,@ioexcl,@libexcl,@opexcl);
  117. foreach $file (@exclist) { $skip{$file}++; }
  118.  
  119. $| = 1;
  120.  
  121. @ARGV = grep($_,@ARGV);  # remove empty elements due to "''p1'" syntax
  122.  
  123. if (lc($ARGV[0]) eq '-v') {
  124.     $verbose = 1;
  125.     shift;
  126. }
  127.  
  128. chdir 't' if -f 't/TEST';
  129.  
  130. if ($ARGV[0] eq '') {
  131.     foreach (<[.*]*.t>) {
  132.       s/.*[\[.]t./[./;
  133.       ($fname = $_) =~ s/.*\]//;
  134.       if ($skip{"\L$fname"}) { push(@skipped,$_); }
  135.       else { push(@ARGV,$_); }
  136.     }
  137. }
  138.  
  139. if (@skipped) {
  140.   print "The following tests were skipped because they rely extensively on\n";
  141.   print " Unixisms not compatible with the current version of perl for VMS:\n";
  142.   print "\t",join("\n\t",@skipped),"\n\n";
  143. }
  144.  
  145. $bad = 0;
  146. $good = 0;
  147. $total = @ARGV;
  148. while ($test = shift) {
  149.     if ($test =~ /^$/) {
  150.     next;
  151.     }
  152.     $te = $test;
  153.     chop($te);
  154.     $te .= '.' x (24 - length($te));
  155.     open(script,"$test") || die "Can't run $test.\n";
  156.     $_ = <script>;
  157.     close(script);
  158.     if (/#!..perl(.*)/) {
  159.         $switch = $1;
  160.         # Add "" to protect uppercase switches on command line
  161.         $switch =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
  162.     } else {
  163.         $switch = '';
  164.     }
  165.     open(results,"\$ MCR Sys\$Disk:[]Perl. \"-I[-.lib]\" $switch $test |") || (print "can't run.\n");
  166.     $ok = 0;
  167.     $next = 0;
  168.     while (<results>) {
  169.     if ($verbose) {
  170.         print "$te$_";
  171.         $te = '';
  172.     }
  173.     unless (/^#/) {
  174.         if (/^1\.\.([0-9]+)/) {
  175.         $max = $1;
  176.         $totmax += $max;
  177.         $files += 1;
  178.         $next = 1;
  179.         $ok = 1;
  180.         } else {
  181.         $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
  182.         next if /^\s*$/; # our 'echo' substitute produces one more \n than Unix'
  183.         if (/^ok (.*)/ && $1 == $next) {
  184.             $next = $next + 1;
  185.         } else {
  186.             $ok = 0;
  187.         }
  188.         }
  189.     }
  190.     }
  191.     $next = $next - 1;
  192.     if ($ok && $next == $max) {
  193.     if ($max) {
  194.         print "${te}ok\n";
  195.         $good = $good + 1;
  196.     } else {
  197.         print "${te}skipping test on this platform\n";
  198.         $files -= 1;
  199.     }
  200.     } else {
  201.     $next += 1;
  202.     print "${te}FAILED on test $next\n";
  203.     $bad = $bad + 1;
  204.     $_ = $test;
  205.     if (/^base/) {
  206.         die "Failed a basic test--cannot continue.\n";
  207.     }
  208.     }
  209. }
  210.  
  211. if ($bad == 0) {
  212.     if ($ok) {
  213.     print "All tests successful.\n";
  214.     } else {
  215.     die "FAILED--no tests were run for some reason.\n";
  216.     }
  217. } else {
  218.     $pct = sprintf("%.2f", $good / $total * 100);
  219.     if ($bad == 1) {
  220.     warn "Failed 1 test, $pct% okay.\n";
  221.     } else {
  222.     warn "Failed $bad/$total tests, $pct% okay.\n";
  223.     }
  224. }
  225. ($user,$sys,$cuser,$csys) = times;
  226. print sprintf("u=%g  s=%g  cu=%g  cs=%g  files=%d  tests=%d\n",
  227.     $user,$sys,$cuser,$csys,$files,$totmax);
  228. $$END-OF-TEST$$
  229. $ wrapup:
  230. $   Show Process/Accounting
  231. $   If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
  232. $   Set Default &olddef
  233. $   Set Message 'oldmsg'
  234. $   Exit
  235.